VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ASMBler"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit


' 32 Bit X86 Assembler
'
' Arne Elster 2007 / 2008


' TODO:
'       * support for instructions like 2-IMUL
'       * more complex expressions for all arguments
'       * Unsigned values (only possible with hex)


Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    pDst As Any, pSrc As Any, ByVal cBytes As Long _
    )


Private Const IMAGE_NUMBEROF_DIRECTORY_ENTRIES  As Long = 16&
Private Const IMAGE_SIZEOF_SHORT_NAME           As Long = 8&
Private Const IMAGE_NT_OPTIONAL_HDR32_MAGIC     As Long = &H10B&
Private Const IMAGE_DOS_HDR16_MAGIC             As Long = &H5A4D&
Private Const IMAGE_DOS_HDR32_MAGIC             As Long = &H4550&
Private Const IMAGE_FILE_MACHINE_I386           As Long = &H14C&

Private Const DOS_CODE_RELOCATIONS As String = _
    "0E1FBA0E00B409CD21B8014CCD21546869732070726" & _
    "F6772616D2063616E6E6F742062652072756E20696E" & _
    "20444F53206D6F64652E0D0D0A2400000000000000"

Private Const MEM_SECTION_SIZE  As Long = 4096
Private Const FILE_SECTION_SIZE As Long = 512

Private Const CHAR_SPACE        As Long = 32
Private Const CHAR_LINEFEED     As Long = 10
Private Const CHAR_CARRIAGE     As Long = 13

Private Const CHAR_QUOTE        As Long = 34
Private Const CHAR_STOP         As Long = 46
Private Const CHAR_SEMICOLON    As Long = 59
Private Const CHAR_COLON        As Long = 58
Private Const CHAR_PLUS         As Long = 43
Private Const CHAR_MINUS        As Long = 45
Private Const CHAR_ASTERISK     As Long = 42
Private Const CHAR_AMPERSAND    As Long = 38
Private Const CHAR_SEPARATOR    As Long = 44
Private Const CHAR_UNDERSCORE   As Long = 95
Private Const CHAR_VERT_BAR     As Long = 124
Private Const CHAR_SHARP        As Long = 35

Private Const CHAR_BRACKET_L    As Long = 91
Private Const CHAR_BRACKET_R    As Long = 93
Private Const CHAR_PARENTH_L    As Long = 40
Private Const CHAR_PARENTH_R    As Long = 41

Private Const CHAR_NUMBER_0     As Long = 48
Private Const CHAR_NUMBER_9     As Long = 57

Private Const CHAR_ALPHA_UA     As Long = 65
Private Const CHAR_ALPHA_UZ     As Long = 90
Private Const CHAR_ALPHA_LA     As Long = 97
Private Const CHAR_ALPHA_LZ     As Long = 122

Private Const REG_COUNT         As Long = 24
Private Const MAX_PARAMETERS    As Long = 3
Private Const MAX_OPCODE_LEN    As Long = 4

Public Enum PESubsystem
    Subsystem_GUI = 2
    Subsystem_CUI = 3
End Enum

Private Enum SectionCharacteristics
    IMAGE_SCN_TYPE_NO_PAD = &H8&
    IMAGE_SCN_CNT_CODE = &H20&
    IMAGE_SCN_CNT_INITIALIZED_DATA = &H40&
    IMAGE_SCN_CNT_UNINITIALIZED_DATA = &H80&
    IMAGE_SCN_LNK_OTHER = &H100&
    IMAGE_SCN_LNK_INFO = &H200&
    IMAGE_SCN_LNK_REMOVE = &H800&
    IMAGE_SCN_LNK_COMDAT = &H1000&
    IMAGE_SCN_NO_DEFER_SPEC_EXC = &H4000&
    IMAGE_SCN_GPREL = &H8000&
    IMAGE_SCN_MEM_PURGEABLE = &H20000
    IMAGE_SCN_MEM_LOCKED = &H40000
    IMAGE_SCN_MEM_PRELOAD = &H80000
    IMAGE_SCN_LNK_NRELOC_OVFL = &H1000000
    IMAGE_SCN_MEM_DISCARDABLE = &H2000000
    IMAGE_SCN_MEM_NOT_CACHED = &H4000000
    IMAGE_SCN_MEM_NOT_PAGED = &H8000000
    IMAGE_SCN_MEM_SHARED = &H10000000
    IMAGE_SCN_MEM_EXECUTE = &H20000000
    IMAGE_SCN_MEM_READ = &H40000000
    IMAGE_SCN_MEM_WRITE = &H80000000
End Enum

Private Enum IMAGE_FILE_CHARACTERISTICS
    IMAGE_FILE_RELOCS_STRIPPED = &H1&
    IMAGE_FILE_EXECUTABLE_IMAGE = &H2&
    IMAGE_FILE_LINE_NUMS_STRIPPED = &H4&
    IMAGE_FILE_LOCAL_SYMS_STRIPPED = &H8&
    IMAGE_FILE_AGGRESSIVE_WS_TRIM = &H10&
    IMAGE_FILE_LARGE_ADDRESS_AWARE = &H20&
    IMAGE_FILE_16BIT_MACHINE = &H40&
    IMAGE_FILE_BYTES_REVERSED_LO = &H80&
    IMAGE_FILE_32BIT_MACHINE = &H100&
    IMAGE_FILE_DEBUG_STRIPPED = &H200&
    IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP = &H400&
    IMAGE_FILE_NET_RUN_FROM_SWAP = &H800&
    IMAGE_FILE_SYSTEM = &H1000&
    IMAGE_FILE_DLL = &H2000&
    IMAGE_FILE_UP_SYSTEM_ONLY = &H4000&
    IMAGE_FILE_BYTES_REVERSED_HI = &H8000&
End Enum

Private Enum OptHeaderTbls
    ETableExport = 0
    ETableImport
    ETableResource
    ETableException
    ETableCertificate
    ETableRelocation
    ETableDebug
    ETableArchitecture
    ETableGlobalPtr
    ETableThreadStorage
    ETableLoadConfig
    ETableBoundImport
    ETableIAT
    ETableDelayImportDescriptor
    ETableCOMPlusRuntime
    ETableReserved
End Enum

Private Type ModRM
    Mod                         As Long
    rm                          As Long
    reg                         As Long
    Disp                        As Long
    DispSize                    As ParamSize
End Type

Private Type SIB
    sscale                      As Long
    Index                       As Long
    base                        As Long
End Type

Private Type ASMLabel
    Name                        As String
    Instruction                 As Long
    Offset                      As Long
End Type

Private Type ASMExtern
    LibName                     As String
    Functions()                 As String
    FunctionCount               As Long
End Type

Private Type Pointer
    Registers(REG_COUNT - 1)    As Long
    UsedRegisters               As Long
    Displacement                As Long
    DispSize                    As ParamSize
End Type

Private Type PointerInfo
    TokenIndex                  As Long
    RegisterCount               As Long
    RegisterMultiples           As Boolean
    HasDisplacement             As Boolean
    DispSize                    As ParamSize
    ptr                         As Pointer
End Type

Private Type RawData
    size                        As ParamSize
    Values()                    As Long
    ValueCount                  As Long
End Type

Private Type ASMArgument
    TType                       As ParamType
    size                        As ParamSize
    Pointer                     As PointerInfo
    Register                    As ASMRegisters
    FPURegister                 As ASMFPURegisters
    MMRegister                  As ASMXMMRegisters
    SymbolIndex                 As Long
    Value                       As Long
End Type

Private Type ASMInstruction
    Mnemonic                    As String
    Segment                     As ASMSegmentRegs
    Args(MAX_PARAMETERS - 1)    As ASMArgument
    OpCodeIndex                 As Long
    ArgCount                    As Long
    size                        As Long
    Offset                      As Long
    flags                       As OpCodePrefixes
    Data                        As RawData
    Line                        As Long
    Section                     As String
End Type

Private Type Scanner
    Source()                    As Byte
    Length                      As Long
    Position                    As Long
    Line                        As Long
    LinePos                     As Long
    Section                     As String
    NextIsEOI                   As Boolean
    LastWasEOI                  As Boolean
    NextToken                   As ASMToken
    CurToken                    As ASMToken
End Type

Private Type IMAGE_IMPORT_DIRECTORY
    ImportLookupTable           As Long
    TimeDateStamp               As Long
    ForwardChain                As Long
    ModuleName                  As Long
    ImportAddressTable          As Long
End Type

Private Type IMAGE_DATA_DIRECTORY
    VirtualAddress              As Long
    size                        As Long
End Type

Private Type IMAGE_SECTION_HEADER
    SectionName(IMAGE_SIZEOF_SHORT_NAME - 1) As Byte
    VirtSizePhysAddr            As Long
    VirtualAddress              As Long
    SizeOfRawData               As Long
    PointerToRawData            As Long
    PointerToRelocations        As Long
    PointerToLinenumbers        As Long
    NumberOfRelocations         As Integer
    NumberOfLinenumbers         As Integer
    Characteristics             As Long
End Type

Private Type IMAGE_OPTIONAL_HEADER
    Magic                       As Integer
    MajorLinkerVersion          As Byte
    MinorLinkerVersion          As Byte
    SizeOfCode                  As Long
    SizeOfInitializedData       As Long
    SizeOfUninitializedData     As Long
    AddressOfEntryPoint         As Long
    BaseOfCode                  As Long
    BaseOfData                  As Long
    ImageBase                   As Long
    SectionAlignment            As Long
    FileAlignment               As Long
    MajorOperatingSystemVersion As Integer
    MinorOperatingSystemVersion As Integer
    MajorImageVersion           As Integer
    MinorImageVersion           As Integer
    MajorSubsystemVersion       As Integer
    MinorSubsystemVersion       As Integer
    Win32VersionValue           As Long
    SizeOfImage                 As Long
    SizeOfHeaders               As Long
    CheckSum                    As Long
    Subsystem                   As Integer
    DllCharacteristics          As Integer
    SizeOfStackReserve          As Long
    SizeOfStackCommit           As Long
    SizeOfHeapReserve           As Long
    SizeOfHeapCommit            As Long
    LoaderFlags                 As Long
    NumberOfRvaAndSizes         As Long
    DataDirectory(IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1)  As IMAGE_DATA_DIRECTORY
End Type

Private Type IMAGE_DOS_HEADER
    Magic                       As Integer
    BytesInLastPage             As Integer
    Pages                       As Integer
    Relocations                 As Integer
    ParagraphsInHeader          As Integer
    MinAlloc                    As Integer
    MaxAlloc                    As Integer
    InitialSS                   As Integer
    InitialSP                   As Integer
    CheckSum                    As Integer
    InitialIP                   As Integer
    InitialCS                   As Integer
    RelocationTableFileAddress  As Integer
    OverlayNumber               As Integer
    Reserved1(3)                As Integer
    OEMIdentifier               As Integer
    OEMInformation              As Integer
    Reserved2(9)                As Integer
    NewHeaderOffset             As Long
End Type

Private Type IMAGE_FILE_HEADER
    Machine                     As Integer
    NumberOfSections            As Integer
    TimeDateStamp               As Long
    PointerToSymbolTable        As Long
    NumberOfSymbols             As Long
    SizeOfOptionalHeader        As Integer
    Characteristics             As Integer
End Type

Private Type IMAGE_NT_HEADERS
    Signature                   As Long
    FileHeader                  As IMAGE_FILE_HEADER
    OptionalHeader              As IMAGE_OPTIONAL_HEADER
End Type

Private m_udtScanner            As Scanner

Private m_clsTokens()           As ASMToken
Private m_lngTokenCount         As Long
Private m_lngCurToken           As Long

Private m_udtLabels()           As ASMLabel
Private m_lngLabelCount         As Long

Private m_udtExtern()           As ASMExtern
Private m_lngExternCount        As Long

Private m_udtInstrs()           As ASMInstruction
Private m_lngInstrCount         As Long

Private m_strLastError          As String
Private m_strLastErrorSection   As String
Private m_lngLastErrLine        As Long

Private m_btOutput()            As Byte
Private m_lngOutSize            As Long
Private m_lngOutPos             As Long

Private m_udeSubsystem          As PESubsystem

Private m_blnWritePE            As Boolean
Private m_lngPECodeSize         As Long

Private m_lngBaseAddress        As Long


Private Sub Class_Initialize()
    InitInstructions
    m_udeSubsystem = Subsystem_CUI
End Sub


Public Property Get Subsystem() As PESubsystem
    Subsystem = m_udeSubsystem
End Property


Public Property Let Subsystem(ByVal lngVal As PESubsystem)
    m_udeSubsystem = lngVal
End Property


Public Property Get PEHeader() As Boolean
    PEHeader = m_blnWritePE
End Property


Public Property Let PEHeader(ByVal blnValue As Boolean)
    m_blnWritePE = blnValue
End Property


Public Property Get BaseAddress() As Long
    BaseAddress = m_lngBaseAddress
End Property


Public Property Let BaseAddress(ByVal lngVal As Long)
    m_lngBaseAddress = lngVal
    If m_lngBaseAddress < 0 Then Err.Raise 6, , "Image Base < 0 invalid"
End Property


Public Property Get LastErrorMessage() As String
    LastErrorMessage = m_strLastError
End Property


Public Property Get LastErrorSection() As String
    LastErrorSection = m_strLastErrorSection
End Property


Public Property Get LastErrorLine() As Long
    LastErrorLine = m_lngLastErrLine
End Property


Public Function GetOutput() As Byte()
    GetOutput = m_btOutput
End Function


Public Property Get OutputSize() As Long
    OutputSize = m_lngOutSize
End Property


' 1. tokenize the input string
' 2. collect all labels
' 3. find all instructions
' 4. find OpCodes for instructions
'    get their sizes and calculate label offsets
' 5. now that the label offsets are known,
'    finally parse pointers
' 6. write instructions to output
' 7. if in PE mode, write IAT (import address table)
Public Function Assemble( _
    strASM As String, _
    Optional ByVal OnlySize As Boolean = False _
    ) As Boolean
    
    ScannerInit strASM
    
    m_lngTokenCount = 0
    m_lngLabelCount = 0
    m_lngInstrCount = 0
    m_lngCurToken = 0
    m_lngOutSize = 0
    m_lngOutPos = 0
    m_lngExternCount = 0
    
    m_strLastError = ""
    m_lngLastErrLine = 0
    
    TokenizeInput
    
    If FindLabels() Then
        If ParseInstructions() Then
            If GetInstructionSizes() Then
                If OnlySize Then
                    Assemble = True
                Else
                    If ParsePointers() Then
                        If m_blnWritePE Then
                            If Not WritePEHeader() Then Exit Function
                        End If
                        
                        If AssembleInstructions() Then
                            If m_blnWritePE Then
                                OutputJumpTo RoundToMinSize(OutputPosition)
                                WritePEImports
                            End If
                            Assemble = True
                        End If
                    End If
                End If
            End If
        End If
    End If
End Function


Private Sub WritePEImports()
    Dim lngRVAIAT   As Long
    Dim ntHdr       As IMAGE_NT_HEADERS
    Dim scHdr       As IMAGE_SECTION_HEADER
    
    Const SECTIONS = 2
    
    lngRVAIAT = RoundToSectionSize(Len(ntHdr) + Len(scHdr) * SECTIONS)
    lngRVAIAT = lngRVAIAT + RoundToSectionSize(m_lngPECodeSize)
    
    WriteIAT lngRVAIAT
    WriteIIDs lngRVAIAT
    WriteIAT lngRVAIAT
    WriteImportedNames
End Sub


Private Sub WriteImportedNames()
    Dim i       As Long
    Dim j       As Long
    
    For i = 0 To m_lngExternCount - 1
        For j = 0 To m_udtExtern(i).FunctionCount - 1
            OutputInteger 0
            WriteStr0Ev m_udtExtern(i).Functions(j)
        Next
        WriteStr0Ev m_udtExtern(i).LibName
    Next
End Sub


Private Sub WriteStr0Ev(ByVal strN As String)
    Dim btN()   As Byte
    
    btN = StrConv(strN & ChrW$(0), vbFromUnicode)
    OutputMem VarPtr(btN(0)), UBound(btN) + 1
    
    If (UBound(btN) + 1) Mod 2 = 1 Then
        OutputByte 0
    End If
End Sub


Private Sub WriteIIDs(ByVal base As Long)
    Dim i       As Long
    Dim j       As Long
    Dim im      As IMAGE_IMPORT_DIRECTORY
    Dim eim     As IMAGE_IMPORT_DIRECTORY
    
    For i = 0 To m_lngExternCount - 1
        With im
            .ModuleName = base + GetRelOfLibname(i)
            .ImportAddressTable = base + GetIATLibStart(i)
            .ImportLookupTable = base + GetILTLibStart(i)
        End With
        
        OutputMem VarPtr(im), Len(im)
    Next
    
    OutputMem VarPtr(eim), Len(eim)
End Sub


Private Sub WriteIAT(ByVal base As Long)
    Dim i   As Long
    Dim j   As Long
    
    For i = 0 To m_lngExternCount - 1
        For j = 0 To m_udtExtern(i).FunctionCount - 1
            OutputLong base + GetRelOfFncname(i, j)
        Next
        OutputLong 0
    Next
End Sub


' address of a function name in the imports section
' relative to the section's start
Private Function GetRelOfFncname(ByVal libdx As Long, ByVal fncidx As Long) As Long
    Dim i   As Long
    Dim j   As Long
    Dim sz  As Long
    Dim im  As IMAGE_IMPORT_DIRECTORY
    
    For i = 0 To m_lngExternCount - 1
        sz = sz + 4 * (m_udtExtern(i).FunctionCount + 1) * 2
        sz = sz + Len(im)
    Next
    If m_lngExternCount > 0 Then sz = sz + Len(im)
    
    For i = 0 To m_lngExternCount - 1
        For j = 0 To m_udtExtern(i).FunctionCount - 1
            If (i = libdx) And (j = fncidx) Then
                GetRelOfFncname = sz
                Exit Function
            Else
                sz = sz + 2 + EvenSize(Len(m_udtExtern(i).Functions(j)) + 1)
            End If
        Next
        sz = sz + EvenSize(Len(m_udtExtern(i).LibName) + 1)
    Next
End Function


' address of a library name in the imports section
' relative to the section's start
Private Function GetRelOfLibname(ByVal Index As Long) As Long
    Dim i   As Long
    Dim j   As Long
    Dim sz  As Long
    Dim im  As IMAGE_IMPORT_DIRECTORY
    
    For i = 0 To m_lngExternCount - 1
        sz = sz + 4 * (m_udtExtern(i).FunctionCount + 1) * 2
        sz = sz + Len(im)
    Next
    If m_lngExternCount > 0 Then sz = sz + Len(im)
    
    For i = 0 To m_lngExternCount - 1
        For j = 0 To m_udtExtern(i).FunctionCount - 1
            sz = sz + 2 + EvenSize(Len(m_udtExtern(i).Functions(j)) + 1)
        Next
        
        If i <> Index Then
            sz = sz + EvenSize(Len(m_udtExtern(i).LibName) + 1)
        Else
            Exit For
        End If
    Next
    
    GetRelOfLibname = sz
End Function


Private Function WritePEHeader() As Boolean
    Dim mzHdr   As IMAGE_DOS_HEADER
    Dim ntHdr   As IMAGE_NT_HEADERS
    Dim scHdr   As IMAGE_SECTION_HEADER
    Dim sdHdr   As IMAGE_SECTION_HEADER
    Dim impTbl  As IMAGE_IMPORT_DIRECTORY
    Dim lngImp  As Long
    Dim btDOS() As Byte
    
    Const SECTIONS = 2
    
    If GetLabelIndex("MAIN") = -1 Then
        SetError "Entrypoint ""Main"" not found.", 0, ""
        Exit Function
    End If
    
    lngImp = GetNeededImportsSize()
    If lngImp = 0 Then lngImp = 1
    
    With mzHdr
        .Magic = IMAGE_DOS_HDR16_MAGIC
        .BytesInLastPage = 144
        .Pages = 3
        .ParagraphsInHeader = 4
        .MaxAlloc = &HFFFF
        .InitialSP = &HB8
        .RelocationTableFileAddress = &H40
        .NewHeaderOffset = Len(mzHdr) + 64
    End With
    
    With ntHdr
        .Signature = IMAGE_DOS_HDR32_MAGIC
        
        With .FileHeader
            .Machine = IMAGE_FILE_MACHINE_I386
            .NumberOfSections = SECTIONS
            .SizeOfOptionalHeader = Len(ntHdr.OptionalHeader)
            .Characteristics = IMAGE_FILE_RELOCS_STRIPPED Or IMAGE_FILE_LINE_NUMS_STRIPPED Or _
            IMAGE_FILE_LOCAL_SYMS_STRIPPED Or IMAGE_FILE_EXECUTABLE_IMAGE Or _
            IMAGE_FILE_32BIT_MACHINE Or IMAGE_FILE_DEBUG_STRIPPED Or _
            IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP Or IMAGE_FILE_NET_RUN_FROM_SWAP
        End With
        
        With .OptionalHeader
            .Magic = IMAGE_NT_OPTIONAL_HDR32_MAGIC
            .SizeOfCode = RoundToMinSize(m_lngPECodeSize)
            .SizeOfInitializedData = RoundToMinSize(lngImp)
            .BaseOfCode = RoundToSectionSize(Len(ntHdr) + Len(scHdr) * SECTIONS)
            .BaseOfData = .BaseOfCode + RoundToSectionSize(.SizeOfCode)
            .AddressOfEntryPoint = m_udtLabels(GetLabelIndex("MAIN")).Offset - m_lngBaseAddress
            .ImageBase = m_lngBaseAddress
            .SectionAlignment = MEM_SECTION_SIZE
            .FileAlignment = FILE_SECTION_SIZE
            .MajorOperatingSystemVersion = 4
            .MajorSubsystemVersion = 4
            .SizeOfImage = .BaseOfData + RoundToSectionSize(lngImp)
            .SizeOfHeaders = GetPEHeaderSize()
            .Subsystem = m_udeSubsystem
            .SizeOfStackReserve = &H100000
            .SizeOfStackCommit = &H1000
            .SizeOfHeapReserve = &H100000
            .SizeOfHeapCommit = &H1000
            .NumberOfRvaAndSizes = 16
            
            With .DataDirectory(ETableImport)
                .VirtualAddress = ntHdr.OptionalHeader.BaseOfCode + _
                RoundToSectionSize(ntHdr.OptionalHeader.SizeOfCode) + _
                GetNeededIATSize()
                
                .size = Len(impTbl)
            End With
            
            With .DataDirectory(ETableIAT)
                .VirtualAddress = ntHdr.OptionalHeader.BaseOfCode + _
                RoundToSectionSize(ntHdr.OptionalHeader.SizeOfCode)
                
                .size = GetNeededIATSize()
            End With
        End With
    End With
    
    With scHdr
        WriteSectionName scHdr, ".text"
        .VirtSizePhysAddr = m_lngPECodeSize
        .VirtualAddress = ntHdr.OptionalHeader.BaseOfCode
        .SizeOfRawData = RoundToMinSize(m_lngPECodeSize)
        .PointerToRawData = GetPEHeaderSize()
        .Characteristics = IMAGE_SCN_CNT_CODE Or _
        IMAGE_SCN_MEM_EXECUTE Or _
        IMAGE_SCN_MEM_READ Or _
        IMAGE_SCN_MEM_WRITE
    End With
    
    With sdHdr
        WriteSectionName sdHdr, ".rdata"
        .VirtSizePhysAddr = lngImp
        .VirtualAddress = ntHdr.OptionalHeader.BaseOfData
        .SizeOfRawData = RoundToMinSize(lngImp)
        .PointerToRawData = scHdr.PointerToRawData + scHdr.SizeOfRawData
        .Characteristics = IMAGE_SCN_MEM_READ Or _
        IMAGE_SCN_MEM_WRITE
    End With
    
    btDOS = HexToByte(DOS_CODE_RELOCATIONS)
    
    OutputMem VarPtr(mzHdr), Len(mzHdr)
    OutputMem VarPtr(btDOS(0)), UBound(btDOS) + 1
    OutputMem VarPtr(ntHdr), Len(ntHdr)
    OutputMem VarPtr(scHdr), Len(scHdr)
    OutputMem VarPtr(sdHdr), Len(sdHdr)
    
    OutputJumpTo RoundToMinSize(OutputPosition)
    
    WritePEHeader = True
End Function


Private Sub WriteSectionName(sc As IMAGE_SECTION_HEADER, ByVal strName As String)
    Dim i   As Long
    
    For i = 1 To Len(strName)
        sc.SectionName(i - 1) = Asc(Mid$(strName, i, 1))
    Next
End Sub


Private Function GetPEHeaderSize() As Long
    Dim mzHdr   As IMAGE_DOS_HEADER
    Dim ntHdr   As IMAGE_NT_HEADERS
    Dim scHdr   As IMAGE_SECTION_HEADER
    
    Const SECTIONS = 2
    
    GetPEHeaderSize = RoundToMinSize(Len(mzHdr) + 64 + Len(ntHdr) + Len(scHdr) * SECTIONS)
End Function


' every instruction has prefixes (opt), an opcode and arguments (opt).
' write them to the output
Private Function AssembleInstructions() As Boolean
    Dim i       As Long
    Dim lngSz   As Long
    
    For i = 0 To m_lngInstrCount - 1
        lngSz = m_lngOutPos
        
        If m_udtInstrs(i).Data.size <> BitsUnknown Then
            If Not RawDataOut(m_udtInstrs(i).Data) Then Exit Function
        Else
            InstructionOutPrefixes m_udtInstrs(i)
            InstructionOutOpCode m_udtInstrs(i)
            If Not InstructionOutArgs(m_udtInstrs(i)) Then Exit Function
        End If
        
        lngSz = m_lngOutPos - lngSz
        If lngSz <> m_udtInstrs(i).size Then Err.Raise 123, , "invalid size after output"
    Next
    
    AssembleInstructions = True
End Function


' db, dw, dd strings
Private Function RawDataOut(Data As RawData) As Boolean
    Dim i   As Long
    
    For i = 0 To Data.ValueCount - 1
        OutputBytes Data.Values(i), Data.size
    Next
    
    RawDataOut = True
End Function


' write arguments to output (modR/M, SIB, Pointers, ...)
' SIB is only written when a pointer has more then 2 registers
' or multiples of a register, or when ESP is used.
Private Function InstructionOutArgs(udtInstr As ASMInstruction) As Boolean
    Dim i               As Long
    Dim j               As Long
    
    Dim udtModRM        As ModRM
    Dim blnModRM        As Boolean
    Dim blnSIBNeeded    As Boolean
    
    Dim lngImmVal()     As Long
    Dim udeImmSize()    As ParamSize
    Dim lngImmValCnt    As Long
    Dim blnImmVal       As Boolean
    
    Dim lngDisplacement As Long
    Dim udeDispSize     As ParamSize
    Dim blnDisplacement As Boolean
    
    Dim lngSIBPtrIdx    As Long
    
    Dim blnGotXMMReg    As Boolean
    Dim lngMMVal        As Long
    
    With Instructions(udtInstr.OpCodeIndex)
        blnModRM = .ModRM
        If .RegOpExt > -1 Then
            udtModRM.reg = .RegOpExt
            blnGotXMMReg = True
        End If
    End With
    
    For i = 0 To udtInstr.ArgCount - 1
        With Instructions(udtInstr.OpCodeIndex).Parameters(i)
            If Not .Forced Then
                
                If (.PType = ParamImm) Or (.PType = ParamRel) Then
                    ' an instruction can have multiple immediates
                    ReDim Preserve lngImmVal(lngImmValCnt) As Long
                    ReDim Preserve udeImmSize(lngImmValCnt) As ParamSize
                    
                    If udtInstr.Args(i).TType = ParamImm Then
                        lngImmVal(lngImmValCnt) = udtInstr.Args(i).Value
                    ElseIf udtInstr.Args(i).TType = ParamRel Then
                        lngImmVal(lngImmValCnt) = m_udtLabels(udtInstr.Args(i).SymbolIndex).Offset
                    End If
                    
                    If .PType = ParamRel Then
                        ' if a relative value is needed, make the immediate
                        ' relative to the end of the current instruction
                        lngImmVal(lngImmValCnt) = lngImmVal(lngImmValCnt) - (udtInstr.Offset + udtInstr.size)
                    End If
                    
                    If (SizesForInt(lngImmVal(lngImmValCnt)) And .size) = 0 Then
                        SetError "Relative value too big for instruction", udtInstr.Line, udtInstr.Section
                        Exit Function
                    End If
                    
                    udeImmSize(lngImmValCnt) = .size
                    lngImmValCnt = lngImmValCnt + 1
                    blnImmVal = True
                    
                ElseIf .PType = ParamReg Then
                    ' register must be put to ModR/M, else it would be "forced"
                    udtModRM.reg = ModRMRegNum(udtInstr.Args(i).Register)
                    
                ElseIf .PType = ParamMM Then
                    Select Case udtInstr.Args(i).MMRegister
                    Case MM0, XMM0: lngMMVal = 0
                    Case MM1, XMM1: lngMMVal = 1
                    Case MM2, XMM2: lngMMVal = 2
                    Case MM3, XMM3: lngMMVal = 3
                    Case MM4, XMM4: lngMMVal = 4
                    Case MM5, XMM5: lngMMVal = 5
                    Case MM6, XMM6: lngMMVal = 6
                    Case MM7, XMM7: lngMMVal = 7
                    End Select
                    
                    If blnGotXMMReg Then
                        udtModRM.Mod = 3
                        udtModRM.rm = lngMMVal
                    Else
                        udtModRM.reg = lngMMVal
                        blnGotXMMReg = True
                    End If
                    
                ElseIf (.PType = (ParamMem Or ParamReg)) Or _
                    (.PType = (ParamMem Or ParamMM)) Or _
                    (.PType = ParamMem) Then
                    
                    If (.PType = ParamMem) And (Not blnModRM) Then
                        ' !#! cann there also be more than one per instruction? !#!
                        lngDisplacement = udtInstr.Args(i).Pointer.ptr.Displacement
                        udeDispSize = Bits32
                        blnDisplacement = True
                    Else
                        If udtInstr.Args(i).TType = ParamMem Then
                            Select Case udtInstr.Args(i).Pointer.RegisterCount
                            Case 0:
                                ' no reigster in the pointer, only displacement possible
                                If udtInstr.Args(i).Pointer.HasDisplacement Then
                                    udtModRM.Disp = udtInstr.Args(i).Pointer.ptr.Displacement
                                    udtModRM.DispSize = Bits32
                                    udtModRM.Mod = 0
                                    udtModRM.rm = 5
                                End If
                                
                            Case 1:
                                ' 1 Register in the pointer, can be encoded with ModR/M
                                ' if its not ESP or a multiple (reg*2/3/4/5/8/9)
                                If udtInstr.Args(i).Pointer.HasDisplacement Then
                                    udtModRM.Disp = udtInstr.Args(i).Pointer.ptr.Displacement
                                    udtModRM.DispSize = udtInstr.Args(i).Pointer.ptr.DispSize
                                    Select Case udtModRM.DispSize
                                    Case Bits8:     udtModRM.Mod = 1
                                    Case Else:      udtModRM.Mod = 2
                                    End Select
                                Else
                                    udtModRM.Mod = 0
                                End If
                                
                                For j = 0 To REG_COUNT - 1
                                    If udtInstr.Args(i).Pointer.ptr.Registers(j) Then
                                        If udtInstr.Args(i).Pointer.ptr.Registers(j) > 1 Then
                                            blnSIBNeeded = True
                                            lngSIBPtrIdx = i
                                        Else
                                            Select Case IdxToReg(j)
                                            Case RegEAX: udtModRM.rm = 0
                                            Case RegECX: udtModRM.rm = 1
                                            Case RegEDX: udtModRM.rm = 2
                                            Case RegEBX: udtModRM.rm = 3
                                            Case RegEBP: udtModRM.rm = 5
                                            Case RegESI: udtModRM.rm = 6
                                            Case RegEDI: udtModRM.rm = 7
                                            Case RegESP: blnSIBNeeded = True
                                                lngSIBPtrIdx = i
                                            End Select
                                        End If
                                        
                                        Exit For
                                    End If
                                Next
                                
                            Case 2:
                                ' 2 registers, SIB needed
                                If udtInstr.Args(i).Pointer.HasDisplacement Then
                                    udtModRM.Disp = udtInstr.Args(i).Pointer.ptr.Displacement
                                    udtModRM.DispSize = udtInstr.Args(i).Pointer.ptr.DispSize
                                    Select Case udtModRM.DispSize
                                    Case Bits8:     udtModRM.Mod = 1
                                    Case Else:      udtModRM.Mod = 2
                                    End Select
                                Else
                                    udtModRM.Mod = 0
                                End If
                                
                                blnSIBNeeded = True
                                lngSIBPtrIdx = i
                                
                            End Select
                            
                        ElseIf udtInstr.Args(i).TType = ParamReg Then
                            ' encode second register in ModR/M
                            udtModRM.Mod = 3
                            udtModRM.rm = ModRMRegNum(udtInstr.Args(i).Register)
                            
                        ElseIf udtInstr.Args(i).TType = (ParamMem Or ParamExt) Then
                            lngDisplacement = udtInstr.Args(i).Pointer.ptr.Displacement
                            udeDispSize = Bits32
                            udtModRM.rm = 5
                            blnDisplacement = True
                            
                        ElseIf udtInstr.Args(i).TType = ParamMM Then
                            Select Case udtInstr.Args(i).MMRegister
                            Case MM0, XMM0: udtModRM.rm = 0
                            Case MM1, XMM1: udtModRM.rm = 1
                            Case MM2, XMM2: udtModRM.rm = 2
                            Case MM3, XMM3: udtModRM.rm = 3
                            Case MM4, XMM4: udtModRM.rm = 4
                            Case MM5, XMM5: udtModRM.rm = 5
                            Case MM6, XMM6: udtModRM.rm = 6
                            Case MM7, XMM7: udtModRM.rm = 7
                            End Select
                            udtModRM.Mod = 3
                            
                        End If
                    End If
                    
                End If
                
            End If
        End With
    Next
    
    If blnSIBNeeded Then
        udtModRM.rm = 4
        If Not WriteSIB(udtInstr, udtModRM, udtInstr.Args(lngSIBPtrIdx).Pointer.ptr) Then
            Exit Function
        End If
    Else
        If blnModRM Then WriteModRM udtModRM
    End If
    
    If blnDisplacement Then OutputBytes lngDisplacement, udeDispSize
    If blnImmVal Then
        For i = 0 To lngImmValCnt - 1
            OutputBytes lngImmVal(i), udeImmSize(i)
        Next
    End If
    
    If Instructions(udtInstr.OpCodeIndex).Now3DByte > -1 Then
        OutputByte Instructions(udtInstr.OpCodeIndex).Now3DByte
    End If
    
    InstructionOutArgs = True
End Function


Private Function WriteSIB( _
    udtInstr As ASMInstruction, _
    rm As ModRM, _
    ptr As Pointer _
    ) As Boolean
    
    Dim udtSIB          As SIB
    Dim udeReg(1)       As ASMRegisters
    Dim lngRegCnt(1)    As Long
    Dim lngScale        As Long
    Dim lngBase         As Long
    Dim i               As Long
    Dim j               As Long
    
    ' find the used registers
    For i = 0 To REG_COUNT - 1
        If ptr.Registers(i) Then
            udeReg(j) = IdxToReg(i)
            lngRegCnt(j) = ptr.Registers(i)
            j = j + 1
        End If
    Next
    
    ' determine the scale register (can have a multiple)
    If lngRegCnt(0) >= 1 And lngRegCnt(1) = 1 Then
        lngScale = 0
    ElseIf lngRegCnt(1) >= 1 And lngRegCnt(0) = 1 Then
        lngScale = 1
    End If
    ' the base register is the other one ;)
    lngBase = 1 - lngScale
    
    If (ptr.UsedRegisters = 1) And (lngRegCnt(0) = 1) Then
        ' olny one register used which isn't a multiple
        udtSIB.sscale = 0
        udtSIB.Index = 4
        
        Select Case udeReg(0)
        Case RegEAX:    udtSIB.base = 0
        Case RegECX:    udtSIB.base = 1
        Case RegEDX:    udtSIB.base = 2
        Case RegEBX:    udtSIB.base = 3
        Case RegESP:    udtSIB.base = 4                                         ' <= all the others encodable in ModR/M
        Case RegEBP:    udtSIB.base = 5
        Case RegESI:    udtSIB.base = 6
        Case RegEDI:    udtSIB.base = 7
        End Select
        
    Else
        
        If (ptr.UsedRegisters = 1) And (lngRegCnt(0) > 1) Then
            ' one register which is a multiple
            If lngRegCnt(0) = 2 Or _
                lngRegCnt(0) = 3 Or _
                lngRegCnt(0) = 5 Or _
                lngRegCnt(0) = 9 Then
                
                If lngRegCnt(0) = 2 Then
                    udtSIB.sscale = 0
                Else
                    udtSIB.sscale = GetFirstSetBitIdx(lngRegCnt(0) - 1)
                End If
                
                Select Case udeReg(0)
                Case RegEAX:    udtSIB.Index = 0:   udtSIB.base = 0
                Case RegECX:    udtSIB.Index = 1:   udtSIB.base = 1
                Case RegEDX:    udtSIB.Index = 2:   udtSIB.base = 2
                Case RegEBX:    udtSIB.Index = 3:   udtSIB.base = 3
                Case RegESI:    udtSIB.Index = 6:   udtSIB.base = 6
                Case RegEDI:    udtSIB.Index = 7:   udtSIB.base = 7
                Case RegEBP:    udtSIB.Index = 5:   udtSIB.base = 5
                    rm.Mod = 1
                Case Else:
                    SetError "invalid multiple of a register in SIB", udtInstr.Line, udtInstr.Section
                    Exit Function
                End Select
                
            ElseIf lngRegCnt(0) = 4 Or lngRegCnt(0) = 8 Then
                ' if Mod of ModR/M byte would be > 0 here
                ' EBP+sbyte/sdword would be encoded, too
                rm.Mod = 0
                udtSIB.base = 5
                udtSIB.sscale = GetFirstSetBitIdx(lngRegCnt(0))
                
                Select Case udeReg(0)
                Case RegEAX:    udtSIB.Index = 0
                Case RegECX:    udtSIB.Index = 1
                Case RegEDX:    udtSIB.Index = 2
                Case RegEBX:    udtSIB.Index = 3
                Case RegEBP:    udtSIB.Index = 5
                Case RegESI:    udtSIB.Index = 6
                Case RegEDI:    udtSIB.Index = 7
                Case Else:
                    SetError "invalid multiples of register in SIB", udtInstr.Line, udtInstr.Section
                    Exit Function
                End Select
                
            Else
                SetError "invalid multiples of register in SIB", udtInstr.Line, udtInstr.Section
                Exit Function
                
            End If
            
        ElseIf ptr.UsedRegisters = 2 Then
            ' 2 register in pointer
            
            Select Case lngRegCnt(lngScale)
            Case 1, 2, 4, 8:
            Case Else:
                SetError "Possible multiples of scale register: 1, 2, 4, 8", udtInstr.Line, udtInstr.Section
                Exit Function
            End Select
            
            If lngRegCnt(lngBase) <> 1 Then
                SetError "Base register mustn't have a multiple", udtInstr.Line, udtInstr.Section
                Exit Function
            End If
            
            ' ESP can only be encoded in the base, so it can't be the scale.
            ' Same thing for EBP, but the other way.
            If (lngRegCnt(lngScale) = 1) And (lngRegCnt(lngBase)) = 1 Then
                If (udeReg(lngScale) = RegESP) Or (udeReg(lngBase) = RegEBP) Then
                    lngScale = lngBase
                    lngBase = 1 - lngScale
                End If
            End If
            
            udtSIB.sscale = GetFirstSetBitIdx(lngRegCnt(lngScale))
            
            Select Case udeReg(lngScale)
            Case RegEAX:    udtSIB.Index = 0
            Case RegECX:    udtSIB.Index = 1
            Case RegEDX:    udtSIB.Index = 2
            Case RegEBX:    udtSIB.Index = 3
            Case RegEBP:    udtSIB.Index = 5
            Case RegESI:    udtSIB.Index = 6
            Case RegEDI:    udtSIB.Index = 7
            Case Else:
                SetError "invalid scale register", udtInstr.Line, udtInstr.Section
                Exit Function
            End Select
            
            Select Case udeReg(lngBase)
            Case RegEAX:    udtSIB.base = 0
            Case RegECX:    udtSIB.base = 1
            Case RegEDX:    udtSIB.base = 2
            Case RegEBX:    udtSIB.base = 3
            Case RegESP:    udtSIB.base = 4
            Case RegEBP:    udtSIB.base = 5
            Case RegESI:    udtSIB.base = 6
            Case RegEDI:    udtSIB.base = 7
            Case Else:
                SetError "invalid base register", udtInstr.Line, udtInstr.Section
                Exit Function
            End Select
        End If
    End If
    
    OutputByte (rm.Mod * &H40) Or (rm.reg * &H8) Or rm.rm
    OutputByte (udtSIB.sscale * &H40) Or (udtSIB.Index * &H8) Or udtSIB.base
    If rm.DispSize <> BitsUnknown Then OutputBytes rm.Disp, rm.DispSize
    
    WriteSIB = True
End Function


Private Function ModRMRegNum(ByVal reg As ASMRegisters) As Long
    Select Case reg
    Case RegAL, RegAX, RegEAX:  ModRMRegNum = 0
    Case RegCL, RegCX, RegECX:  ModRMRegNum = 1
    Case RegDL, RegDX, RegEDX:  ModRMRegNum = 2
    Case RegBL, RegBX, RegEBX:  ModRMRegNum = 3
    Case RegAH, RegSP, RegESP:  ModRMRegNum = 4
    Case RegCH, RegBP, RegEBP:  ModRMRegNum = 5
    Case RegDH, RegSI, RegESI:  ModRMRegNum = 6
    Case RegBH, RegDI, RegEDI:  ModRMRegNum = 7
    End Select
End Function


Private Sub WriteModRM(rm As ModRM)
    OutputByte (rm.Mod * &H40) Or (rm.reg * &H8) Or rm.rm
    If rm.DispSize <> BitsUnknown Then OutputBytes rm.Disp, rm.DispSize
End Sub


Private Sub InstructionOutOpCode(udtInstr As ASMInstruction)
    Dim i As Long
    
    With Instructions(udtInstr.OpCodeIndex)
        For i = 0 To .OpCodeLen - 1
            OutputByte .OpCode(i)
        Next
    End With
End Sub


Private Sub InstructionOutPrefixes(udtInstr As ASMInstruction)
    With Instructions(udtInstr.OpCodeIndex)
        If (.Prefixes And PrefixFlgOperandSizeOverride) Then _
        OutputByte PREFIX_OPERAND_SIZE_OVERRIDE
        If (.Prefixes And PrefixFlgAddressSizeOverride) Then _
        OutputByte PREFIX_ADDRESS_SIZE_OVERRIDE
        If (.Prefixes And PrefixFlgBranchNotTaken) Then _
        OutputByte PREFIX_BRANCH_NOT_TAKEN
        If (.Prefixes And PrefixFlgBranchTaken) Then _
        OutputByte PREFIX_BRANCH_TAKEN
    End With
    
    With udtInstr
        If (.flags And PrefixFlgLock) Then _
        OutputByte PREFIX_LOCK
        If (.flags And PrefixFlgRep) Then _
        OutputByte PREFIX_REP
        If (.flags And PrefixFlgRepne) Then _
        OutputByte PREFIX_REPNE
    End With
    
    Select Case udtInstr.Segment
    Case SegCS: OutputByte PREFIX_SEGMENT_CS
    Case SegDS: OutputByte PREFIX_SEGMENT_DS
    Case SegES: OutputByte PREFIX_SEGMENT_ES
    Case SegFS: OutputByte PREFIX_SEGMENT_FS
    Case SegGS: OutputByte PREFIX_SEGMENT_GS
    Case SegSS: OutputByte PREFIX_SEGMENT_SS
    End Select
End Sub


Private Sub OutputMem(ByVal ptr As Long, ByVal Bytes As Long)
    If m_lngOutPos + Bytes > m_lngOutSize Then
        Err.Raise 123456, , "not enough space in output array"
    End If
    
    CopyMemory m_btOutput(m_lngOutPos), ByVal ptr, Bytes
    m_lngOutPos = m_lngOutPos + Bytes
End Sub


Private Sub OutputJumpTo(ByVal lngVal As Long)
    If (lngVal >= m_lngOutSize) Or (lngVal < 0) Then
        Err.Raise 123456, , "new position out of bounds"
    End If
    
    m_lngOutPos = lngVal
End Sub


Private Property Get OutputPosition() As Long
    OutputPosition = m_lngOutPos
End Property


Private Sub OutputBytes(ByVal Value As Long, ByVal size As ParamSize)
    Select Case size
    Case Bits8:     OutputByte Value
    Case Bits16:    OutputInteger Value
    Case Bits32:    OutputLong Value
    Case Else:      Err.Raise 123456, , "invalid size"
    End Select
End Sub


Private Sub OutputByte(ByVal Value As Long)
    If Value < 0 Then
        m_btOutput(m_lngOutPos) = CByte(Value + 256)                            ' Signed Byte
    Else
        m_btOutput(m_lngOutPos) = CByte(Value)
    End If
    
    m_lngOutPos = m_lngOutPos + 1
End Sub


Private Sub OutputInteger(ByVal Value As Long)
    CopyMemory m_btOutput(m_lngOutPos), Value, 2
    m_lngOutPos = m_lngOutPos + 2
End Sub


Private Sub OutputLong(ByVal Value As Long)
    CopyMemory m_btOutput(m_lngOutPos), Value, 4
    m_lngOutPos = m_lngOutPos + 4
End Sub


Private Function ParsePointers() As Boolean
    Dim i   As Long
    Dim j   As Long
    
    For i = 0 To m_lngInstrCount - 1
        For j = 0 To m_udtInstrs(i).ArgCount - 1
            With m_udtInstrs(i).Args(j)
                If .TType = ParamMem Then
                    m_lngCurToken = .Pointer.TokenIndex
                    If Not ParsePointer(.Pointer.ptr) Then Exit Function
                End If
            End With
        Next
    Next
    
    ParsePointers = True
End Function


Private Function ParsePointer(ptr As Pointer) As Boolean
    Dim lngSgn      As Long
    Dim lngTms      As Long
    Dim lngVal      As Long
    Dim i           As Long
    Dim lngReg      As Long
    Dim blnReg      As Boolean
    
    If Not Match(TokenBracketLeft) Then
        SetError """["" expected", Token.Line, Token.Section
        Exit Function
    End If
    
    If Match(TokenOpAdd) Then
        lngSgn = 1
    ElseIf Match(TokenOpSub) Then
        lngSgn = -1
    Else
        lngSgn = 1
    End If
    
    Do
        lngTms = 1
        blnReg = False
        
        Do
            Select Case Token.TType
            Case TokenRegister:
                blnReg = True
                lngReg = RegToIdx(RegStrToReg(Token.Content))
                Match TokenRegister
            Case TokenValue:
                lngTms = lngTms * Token.Value
                Match TokenValue
            Case TokenSymbol:
                lngTms = lngTms * m_udtLabels(GetLabelIndex(Token.Content)).Offset
                Match TokenSymbol
            End Select
        Loop While Match(TokenOpMul)
        
        If blnReg Then
            ptr.Registers(lngReg) = ptr.Registers(lngReg) + lngSgn * lngTms
        Else
            ptr.Displacement = ptr.Displacement + lngSgn * lngTms
        End If
        
        If Match(TokenOpAdd) Then
            lngSgn = 1
        ElseIf Match(TokenOpSub) Then
            lngSgn = -1
        Else
            Exit Do
        End If
    Loop
    
    If Not Match(TokenBracketRight) Then
        SetError """]"" expected", Token.Line, Token.Section
    Else
        ParsePointer = True
    End If
End Function


Private Function GetInstructionSizes() As Boolean
    Dim i           As Long
    Dim j           As Long
    Dim k           As Long
    Dim size        As Long
    Dim lngImpSz    As Long
    Dim blnFoundI   As Boolean
    
    For i = 0 To m_lngInstrCount - 1                                            ' all instructions in the source
        If m_udtInstrs(i).Data.size <> BitsUnknown Then
            With m_udtInstrs(i)
                .size = .Data.ValueCount * .Data.size \ 8
            End With
        Else
            blnFoundI = False
            
            For j = 0 To InstructionCount - 1                                   ' all known instructions
                If StrComp(m_udtInstrs(i).Mnemonic, Instructions(j).Mnemonic, vbTextCompare) = 0 Then
                    blnFoundI = True
                    
                    If CompareInstrs(m_udtInstrs(i), Instructions(j)) Then
                        ' OpCode length + all used prefixes, ModR/M Byte
                        size = Instructions(j).OpCodeLen + _
                        BitCount(Instructions(j).Prefixes Or m_udtInstrs(i).flags) + _
                        Abs(m_udtInstrs(i).Segment <> SegUnknown) + _
                        Abs(Instructions(j).ModRM) + _
                        Abs(Instructions(j).Now3DByte > -1)
                        
                        ' immediates, displacement, SIB byte
                        If Instructions(j).ParamCount > 0 Then
                            For k = 0 To Instructions(j).ParamCount - 1
                                With Instructions(j).Parameters(k)
                                    If Not .Forced Then
                                        
                                        Select Case .PType
                                            
                                        Case ParamImm, ParamRel:
                                            size = size + .size \ 8             ' Imm
                                            
                                        Case ParamMem Or ParamReg, ParamMem:
                                            If Not Instructions(j).ModRM And .PType = ParamMem Then
                                                size = size + 4                 ' Imm
                                            Else
                                                If m_udtInstrs(i).Args(k).Pointer.HasDisplacement Then
                                                    size = size + m_udtInstrs(i).Args(k).Pointer.DispSize \ 8
                                                End If
                                                
                                                If m_udtInstrs(i).Args(k).Pointer.RegisterCount = 2 Or _
                                                    m_udtInstrs(i).Args(k).Pointer.RegisterMultiples Then
                                                    size = size + 1             ' SIB
                                                End If
                                            End If
                                            
                                        End Select
                                        
                                    End If
                                End With
                            Next
                        End If
                        
                        m_udtInstrs(i).OpCodeIndex = j
                        m_udtInstrs(i).size = size
                        Exit For
                    End If
                End If
            Next
            
            If j = InstructionCount Then
                If blnFoundI Then
                    SetError "invalid arguments", m_udtInstrs(i).Line, m_udtInstrs(i).Section
                Else
                    SetError "unknown instruction: " & m_udtInstrs(i).Mnemonic, m_udtInstrs(i).Line, m_udtInstrs(i).Section
                End If
                
                Exit Function
            End If
        End If
    Next
    
    FillInOffsets
    If m_blnWritePE Then
        m_lngPECodeSize = m_lngOutSize
        
        lngImpSz = GetNeededImportsSize()
        If lngImpSz = 0 Then
            m_lngOutSize = RoundToMinSize(GetPEHeaderSize()) + _
            RoundToMinSize(m_lngPECodeSize) + _
            RoundToMinSize(1)
        Else
            m_lngOutSize = RoundToMinSize(GetPEHeaderSize()) + _
            RoundToMinSize(m_lngPECodeSize) + _
            RoundToMinSize(lngImpSz)
        End If
        
        FillInIAT RoundToSectionSize(GetPEHeaderSize()) + _
        RoundToSectionSize(m_lngPECodeSize)
    End If
    
    ReDim m_btOutput(m_lngOutSize - 1) As Byte
    
    GetInstructionSizes = True
End Function


' calculate label- and instructionoffsets
Private Sub FillInOffsets()
    Dim i           As Long
    Dim j           As Long
    Dim lngPEOffset As Long
    
    If m_blnWritePE Then
        lngPEOffset = RoundToSectionSize(GetPEHeaderSize)
    End If
    
    For i = 0 To m_lngInstrCount - 1
        m_udtInstrs(i).Offset = m_lngOutSize + m_lngBaseAddress + lngPEOffset
        m_lngOutSize = m_lngOutSize + m_udtInstrs(i).size
        
        If j < m_lngLabelCount Then
            If m_udtLabels(j).Instruction = i Then
                m_udtLabels(j).Offset = m_udtInstrs(i).Offset
                j = j + 1
            End If
        End If
    Next
    
    If j < m_lngLabelCount Then
        With m_udtInstrs(m_lngInstrCount - 1)
            For j = j To m_lngLabelCount - 1
                m_udtLabels(j).Offset = .Offset
            Next
        End With
    End If
End Sub


' calculate jump addresses for imported functions
Private Sub FillInIAT(ByVal reladdr As Long)
    Dim i           As Long
    Dim j           As Long
    Dim k           As Long
    Dim libidx      As Long
    Dim fncidx      As Long
    
    For i = 0 To m_lngInstrCount - 1
        For j = 0 To m_udtInstrs(i).ArgCount - 1
            If (m_udtInstrs(i).Args(j).TType And ParamExt) Then
                libidx = (m_udtInstrs(i).Args(j).SymbolIndex \ &H10000) And &HFFFF&
                fncidx = m_udtInstrs(i).Args(j).SymbolIndex And &HFFFF&
                m_udtInstrs(i).Args(j).Pointer.ptr.Displacement = GetExternRelOfFnc(libidx, fncidx, reladdr)
            End If
        Next
    Next
End Sub


' compare parsed instruction with one of the instruction set
Private Function CompareInstrs( _
    src As ASMInstruction, _
    comp As Instruction _
    ) As Boolean
    
    Dim i   As Long
    
    If src.ArgCount = comp.ParamCount Then
        For i = 0 To src.ArgCount - 1
            ' imm and rel should be treated equal
            With comp.Parameters(i)
                If (.PType And src.Args(i).TType) = 0 Then
                    If Not (.PType = ParamImm And src.Args(i).TType = ParamRel) Then
                        If Not (.PType = ParamRel And src.Args(i).TType = ParamImm) Then
                            Exit Function
                        End If
                    End If
                End If
            End With
            
            If comp.Parameters(i).Forced Then
                Select Case comp.Parameters(i).PType
                Case ParamReg:
                    If src.Args(i).Register <> comp.Parameters(i).Register Then
                        Exit Function
                    End If
                Case ParamSTX:
                    If src.Args(i).FPURegister <> comp.Parameters(i).FPURegister Then
                        Exit Function
                    End If
                Case ParamImm:
                    If src.Args(i).Value <> comp.Parameters(i).Value Then
                        Exit Function
                    End If
                End Select
            Else
                If comp.Parameters(i).PType = ParamMem Then
                    If Not comp.ModRM Then
                        If src.Args(i).Pointer.RegisterCount > 0 Then
                            ' instruction mustn't have registers in the pointer
                            ' because ModR/M isn't allowed for it
                            Exit Function
                        End If
                    End If
                ElseIf (comp.Parameters(i).PType And ParamMM) Then
                    If IsDefinite(comp.Parameters(i).MMRegister) Then
                        If comp.Parameters(i).MMRegister <> src.Args(i).MMRegister Then
                            Exit Function
                        End If
                    Else
                        If src.Args(i).TType = ParamMem Then
                            If (comp.Parameters(i).PType And ParamMem) = 0 Then
                                Exit Function
                            End If
                        Else
                            If (comp.Parameters(i).MMRegister And src.Args(i).MMRegister) = 0 Then
                                Exit Function
                            End If
                        End If
                    End If
                End If
            End If
            
            If (comp.Parameters(i).size And src.Args(i).size) = 0 Then
                If comp.Parameters(i).size <> BitsUnknown Then
                    Exit Function
                End If
            End If
        Next
        
        CompareInstrs = True
    End If
End Function


' collect labels
Private Function FindLabels() As Boolean
    Dim i           As Long
    Dim lngInstrCnt As Long
    
    For i = 1 To m_lngTokenCount - 2
        If m_clsTokens(i).TType = TokenSymbol Then
            If m_clsTokens(i + 1).TType = TokenOpColon Then
                If GetLabelIndex(m_clsTokens(i).Content) > -1 Then
                    SetError "ambigious names: " & m_clsTokens(i).Content, m_clsTokens(i).Line, m_clsTokens(i).Section
                    Exit Function
                End If
                AddLabel m_clsTokens(i).Content, lngInstrCnt
            End If
        ElseIf m_clsTokens(i).TType = TokenOperator Then
            lngInstrCnt = lngInstrCnt + 1
        ElseIf m_clsTokens(i).TType = TokenRawData Then
            lngInstrCnt = lngInstrCnt + 1
        End If
    Next
    
    FindLabels = True
End Function


' skips labels because they're already collected
Private Function ParseInstructions() As Boolean
    If Not Match(TokenBeginOfInput) Then
        SetError "Unknown error occured while starting parsing", 0, ""
    Else
        Do While Token.TType <> TokenEndOfInput
            Select Case Token.TType
                
            Case TokenExtern:
                If m_blnWritePE Then
                    Match TokenExtern
                    If Not ParseExtern() Then Exit Do
                Else
                    SetError "Externs only allowed in PE mode", Token.Line, Token.Section
                    Exit Function
                End If
                
            Case TokenSymbol:
                Match TokenSymbol
                If Not Match(TokenOpColon) Then
                    SetError """:"" expected after label ID", Token.Line, Token.Section
                    Exit Do
                End If
                
            Case TokenOperator, TokenKeyword:
                If Not ParseInstruction Then Exit Do
                
            Case TokenRawData:
                If Not ParseRawData Then Exit Do
                
            Case Else:
                If Token.TType <> TokenEndOfInstruction Then
                    SetError "Unexpected symbol: " & Token.Content, Token.Line, Token.Section
                    Exit Do
                End If
                
            End Select
            
            If Not Match(TokenEndOfInstruction) Then
                SetError "Unexpected end", Token.Line, Token.Section
                Exit Do
            Else
                ParseInstructions = Token.TType = TokenEndOfInput
            End If
        Loop
    End If
End Function


Private Function AddExtern(ByVal lib As String, ByVal fnc As String) As Boolean
    Dim i   As Long
    Dim j   As Long
    
    AddExtern = True
    
    For i = 0 To m_lngExternCount - 1
        If StrComp(m_udtExtern(i).LibName, lib, vbTextCompare) = 0 Then
            For j = 0 To m_udtExtern(i).FunctionCount - 1
                If StrComp(m_udtExtern(i).Functions(j), fnc, vbTextCompare) = 0 Then
                    Exit Function
                End If
            Next
            
            With m_udtExtern(i)
                ReDim Preserve .Functions(.FunctionCount) As String
                .Functions(.FunctionCount) = fnc
                .FunctionCount = .FunctionCount + 1
            End With
            Exit Function
        End If
    Next
    
    If i = m_lngExternCount Then
        ReDim Preserve m_udtExtern(m_lngExternCount) As ASMExtern
        
        With m_udtExtern(m_lngExternCount)
            .LibName = lib
            
            ReDim .Functions(0) As String
            .Functions(0) = fnc
            .FunctionCount = 1
        End With
        
        m_lngExternCount = m_lngExternCount + 1
    End If
End Function


Private Function ParseExtern() As Boolean
    Dim strLib  As String
    Dim strFnc  As String
    
    If Token.TType <> TokenString Then
        SetError "Expected: string identifier for library name", Token.Line, Token.Section
        Exit Function
    Else
        strLib = Token.Content
        Match TokenString
        
        If Not Match(TokenSeparator) Then
            SetError "Libraryname and functionname have to be seperated through a "",""", Token.Line, Token.Section
            Exit Function
        Else
            If Token.TType <> TokenSymbol Then
                SetError "Expected: Name of the exporte function", Token.Line, Token.Section
                Exit Function
            Else
                strFnc = Token.Content
                Match TokenSymbol
                
                If GetLabelIndex(strFnc) > -1 Then
                    SetError "Name not unique", Token.Line, Token.Section
                Else
                    ParseExtern = AddExtern(strLib, strFnc)
                End If
            End If
        End If
    End If
End Function


Private Function ParseRawData() As Boolean
    Dim udtInstr    As ASMInstruction
    Dim i           As Long
    Dim lngLen      As Long
    Dim lngTemp     As Long
    
    Select Case UCase$(Token.Content)
    Case "DB":  udtInstr.Data.size = Bits8
    Case "DW":  udtInstr.Data.size = Bits16
    Case "DD":  udtInstr.Data.size = Bits32
    End Select
    Match TokenRawData
    
    With udtInstr.Data
        Do
            Select Case Token.TType
            Case TokenValue:
                ReDim Preserve .Values(.ValueCount) As Long
                .Values(.ValueCount) = Token.Value
                .ValueCount = .ValueCount + 1
                Match TokenValue
                
            Case TokenString:
                lngTemp = .ValueCount
                
                ReDim Preserve .Values(.ValueCount + Len(Token.Content) - 1) As Long
                For i = 1 To Len(Token.Content)
                    .Values(lngTemp + i - 1) = Asc(Mid$(Token.Content, i, 1))
                Next
                
                .ValueCount = .ValueCount + Len(Token.Content)
                Match TokenString
                
            Case Else:
                SetError "Unexpected: " & Token.Content, udtInstr.Line, udtInstr.Section
                Exit Function
                
            End Select
        Loop While Match(TokenSeparator)
    End With
    
    AddInstruction udtInstr
    
    ParseRawData = True
End Function


Private Function ParseInstruction() As Boolean
    Dim udtInstr    As ASMInstruction
    
    ' instruction can have multiple keywords like "lock rep"
    Do While Token.TType = TokenKeyword
        Select Case UCase$(Token.Content)
        Case "REP":     udtInstr.flags = udtInstr.flags Or PrefixFlgRep
        Case "REPE":    udtInstr.flags = udtInstr.flags Or PrefixFlgRepe
        Case "REPZ":    udtInstr.flags = udtInstr.flags Or PrefixFlgRepz
        Case "REPNE":   udtInstr.flags = udtInstr.flags Or PrefixFlgRepne
        Case "REPNZ":   udtInstr.flags = udtInstr.flags Or PrefixFlgRepnz
        Case "LOCK":    udtInstr.flags = udtInstr.flags Or PrefixFlgLock
        Case Else:      SetError "Unknown keyword: " & Token.Content, Token.Line, Token.Section
            Exit Function
        End Select
        
        Match TokenKeyword
    Loop
    
    If Token.TType <> TokenOperator Then
        SetError "Operator expected", Token.Line, Token.Section
    Else
        udtInstr.Mnemonic = Token.Content
        udtInstr.Line = Token.Line
        udtInstr.Section = Token.Section
        
        Match TokenOperator
        
        If ParseArguments(udtInstr) Then
            AddInstruction udtInstr
            ParseInstruction = True
        End If
    End If
End Function


' Reads up to 3 arguments per instruction.
' First keywords are read, then the rest like labels, numerical values,
' registers or pointers.
Private Function ParseArguments(udtInstr As ASMInstruction) As Boolean
    Dim lngArgs     As Long
    Dim lngPtrIdx   As Long
    Dim blnCont     As Boolean
    
    lngPtrIdx = -1
    
    Do
        If lngArgs = 3 Then
            SetError "Too many arguments", udtInstr.Line, udtInstr.Section
            Exit Function
        End If
        
        If Token.TType = TokenKeyword Then
            If Not ParseKeywords(udtInstr, lngArgs) Then Exit Function
        End If
        
        blnCont = False
        Select Case Token.TType
        Case TokenRegister:
            If Not ParseArgumentRegister(udtInstr, udtInstr.Args(lngArgs)) Then Exit Function
        Case TokenFPUReg:
            If Not ParseArgumentFPUReg(udtInstr, udtInstr.Args(lngArgs)) Then Exit Function
        Case TokenMMRegister:
            If Not ParseArgumentMMReg(udtInstr, udtInstr.Args(lngArgs)) Then Exit Function
        Case TokenSymbol:
            If Not ParseArgumentSymbol(udtInstr, udtInstr.Args(lngArgs)) Then Exit Function
        Case TokenValue:
            If Not ParseArgumentValue(udtInstr, udtInstr.Args(lngArgs)) Then Exit Function
        Case TokenBracketLeft:
            If Not ParseArgumentPtr(udtInstr, udtInstr.Args(lngArgs)) Then Exit Function
            lngPtrIdx = lngArgs
        Case TokenSegmentReg:
            If Not ParseSegmentReg(udtInstr) Then Exit Function
            blnCont = True
        Case TokenEndOfInstruction:
            Exit Do
        Case Else:
            SetError "Unexpected: " & Token.Content, udtInstr.Line, udtInstr.Section
            Exit Function
        End Select
        
        If Not blnCont Then lngArgs = lngArgs + 1
    Loop While Match(TokenSeparator) Or blnCont
    
    If lngPtrIdx > -1 Then
        If udtInstr.Args(lngPtrIdx).size = BitsUnknown Then
            If lngArgs = 2 Then
                If IsDefinite(udtInstr.Args(1 - lngPtrIdx).size) Or _
                    (udtInstr.Args(1 - lngPtrIdx).TType And ParamMM) Then
                    udtInstr.Args(lngPtrIdx).size = udtInstr.Args(1 - lngPtrIdx).size
                Else
                    SetError "Invalid pointer size", udtInstr.Line, udtInstr.Section
                    Exit Function
                End If
            End If
        End If
    End If
    
    udtInstr.ArgCount = lngArgs
    ParseArguments = True
End Function


Private Function ParseArgumentPtr( _
    udtInstr As ASMInstruction, _
    arg As ASMArgument _
    ) As Boolean
    
    arg.TType = ParamMem
    arg.Pointer.TokenIndex = m_lngCurToken
    ParseArgumentPtr = ValidatePointer(udtInstr, arg.Pointer)
End Function


Private Function ParseArgumentValue( _
    udtInstr As ASMInstruction, _
    arg As ASMArgument _
    ) As Boolean
    
    arg.TType = ParamImm
    arg.Value = Token.Value
    
    If arg.size = BitsUnknown Then
        arg.size = SizesForInt(Token.Value)
    Else
        If (arg.size And SizesForInt(Token.Value)) = 0 Then
            SetError "Incompatible integer sizes", udtInstr.Line, udtInstr.Section
            Exit Function
        End If
    End If
    
    Match TokenValue
    ParseArgumentValue = True
End Function


Private Function ParseArgumentSymbol( _
    udtInstr As ASMInstruction, _
    arg As ASMArgument _
    ) As Boolean
    
    Dim lngLblIdx   As Long
    Dim blnExtern   As Boolean
    
    lngLblIdx = GetLabelIndex(Token.Content)
    If lngLblIdx = -1 Then
        lngLblIdx = GetExternIndex(Token.Content)
        If lngLblIdx = -1 Then
            SetError "Unknown label: " & Token.Content, udtInstr.Line, udtInstr.Section
            Exit Function
        Else
            blnExtern = True
        End If
    End If
    
    If blnExtern Then
        arg.TType = ParamMem Or ParamExt
        arg.SymbolIndex = lngLblIdx
        arg.size = Bits32
        
        arg.Pointer.HasDisplacement = True
        arg.Pointer.ptr.DispSize = Bits32
        arg.Pointer.DispSize = Bits32
    Else
        arg.TType = ParamRel
        arg.SymbolIndex = lngLblIdx
        
        If arg.size = BitsUnknown Then
            arg.size = Bits32 Or Bits16 Or Bits8
        End If
    End If
    
    Match TokenSymbol
    ParseArgumentSymbol = True
End Function


Private Function ParseArgumentMMReg( _
    udtInstr As ASMInstruction, _
    arg As ASMArgument _
    ) As Boolean
    
    arg.TType = ParamMM
    arg.MMRegister = MMRegStrToNum(Token.Content)
    
    If arg.size <> BitsUnknown Then
        If (arg.size And (Bits32 Or Bits64 Or Bits80 Or Bits128)) = 0 Then
            SetError "Incompatible sizes", udtInstr.Line, udtInstr.Section
            Exit Function
        End If
    Else
        If (arg.MMRegister < XMM0) Then
            arg.size = Bits64
        Else
            arg.size = Bits128
        End If
    End If
    
    Match TokenMMRegister
    ParseArgumentMMReg = True
End Function


Private Function ParseArgumentFPUReg( _
    udtInstr As ASMInstruction, _
    arg As ASMArgument _
    ) As Boolean
    
    arg.TType = ParamSTX
    arg.FPURegister = FPURegStrToNum(Token.Content)
    
    If arg.size <> BitsUnknown Then
        If (arg.size And (Bits32 Or Bits64 Or Bits80)) = 0 Then
            SetError "Incompatible sizes", udtInstr.Line, udtInstr.Section
            Exit Function
        End If
    Else
        arg.size = Bits32 Or Bits64 Or Bits80
    End If
    
    Match TokenFPUReg
    ParseArgumentFPUReg = True
End Function


Private Function ParseArgumentRegister( _
    udtInstr As ASMInstruction, _
    arg As ASMArgument _
    ) As Boolean
    
    arg.TType = ParamReg
    arg.Register = RegStrToReg(Token.Content)
    
    If arg.size <> BitsUnknown Then
        If arg.size <> RegisterSize(arg.Register) Then
            SetError "Incompatible sizes", udtInstr.Line, udtInstr.Section
            Exit Function
        End If
    Else
        arg.size = RegisterSize(arg.Register)
    End If
    
    Match TokenRegister
    ParseArgumentRegister = True
End Function


' Only sizes IDs valid at this position. "byte dword" causes an error at "dword"
Private Function ParseKeywords( _
    udtInstr As ASMInstruction, _
    argidx As Long _
    ) As Boolean
    
    Select Case UCase$(Token.Content)
    Case "BYTE":                udtInstr.Args(argidx).size = Bits8
    Case "WORD":                udtInstr.Args(argidx).size = Bits16
    Case "DWORD", "FLOAT":      udtInstr.Args(argidx).size = Bits32
    Case "QWORD", "DOUBLE":     udtInstr.Args(argidx).size = Bits64
    Case "EXTENDED":            udtInstr.Args(argidx).size = Bits80
    Case "DQWORD":              udtInstr.Args(argidx).size = Bits128
    Case Else:                  SetError "At this position invalid: " & Token.Content, udtInstr.Line, udtInstr.Section
        Exit Function
    End Select
    
    Match TokenKeyword
    ParseKeywords = True
End Function


Private Function ValidatePointer( _
    udtInstr As ASMInstruction, _
    ptr As PointerInfo _
    ) As Boolean
    
    If Not Match(TokenBracketLeft) Then
        SetError "Expected: [", udtInstr.Line, udtInstr.Section
    Else
        If ValidateExpr(udtInstr, ptr) Then
            If Not Match(TokenBracketRight) Then
                SetError """["" Expected", udtInstr.Line, udtInstr.Section
            Else
                ValidatePointer = True
            End If
        End If
    End If
End Function


' validate expressions in brackets ( e.g. "[eax*2+ebp-10]" )
Private Function ValidateExpr( _
    udtInstr As ASMInstruction, _
    ptr As PointerInfo _
    ) As Boolean
    
    Dim lngRegCount(REG_COUNT - 1)  As Long
    Dim lngUsedRegs(1)              As Long
    Dim lngDisplacement             As Long
    Dim lngSign                     As Long
    Dim lngReg                      As Long
    Dim lngTms                      As Long
    Dim i                           As Long
    Dim blnHasSymbols               As Boolean
    Dim blnHasSymbol                As Boolean
    Dim blnHasRegister              As Boolean
    
    If Match(TokenOpAdd) Then
        lngSign = 1
    ElseIf Match(TokenOpSub) Then
        lngSign = -1
    Else
        lngSign = 1
    End If
    
    Do
        lngTms = 1
        blnHasSymbol = False
        blnHasRegister = False
        
        Do
            Select Case Token.TType
            Case TokenRegister:
                If blnHasRegister Then
                    SetError "Power of register not possible", udtInstr.Line, udtInstr.Section
                    Exit Function
                End If
                
                If blnHasSymbol Then
                    SetError "Register*Label not possible", udtInstr.Line, udtInstr.Section
                    Exit Function
                End If
                
                If RegStrToReg(Token.Content) < RegEAX Then
                    SetError "Only 32 bit registers allowed in pointer", udtInstr.Line, udtInstr.Section
                    Exit Function
                End If
                
                lngReg = RegToIdx(RegStrToReg(Token.Content))
                blnHasRegister = True
                Match TokenRegister
                
            Case TokenValue:
                lngTms = lngTms * Token.Value
                Match TokenValue
                
            Case TokenSymbol:
                If blnHasRegister Then
                    SetError "Register*Label not possible", udtInstr.Line, udtInstr.Section
                    Exit Function
                End If
                
                If GetLabelIndex(Token.Content) = -1 Then
                    SetError "Unknown symbol: " & Token.Content, udtInstr.Line, udtInstr.Section
                    Exit Function
                End If
                
                blnHasSymbol = True
                blnHasSymbols = True
                Match TokenSymbol
                
            Case Else:
                SetError "Invalid in pointer: " & Token.Content, udtInstr.Line, udtInstr.Section
                Exit Function
                
            End Select
        Loop While Match(TokenOpMul)
        
        If blnHasRegister Then
            lngRegCount(lngReg) = lngRegCount(lngReg) + lngSign * lngTms
        Else
            lngDisplacement = lngDisplacement + lngSign * lngTms
        End If
        
        If Match(TokenOpAdd) Then
            lngSign = 1
        ElseIf Match(TokenOpSub) Then
            lngSign = -1
        Else
            Exit Do
        End If
    Loop
    
    For i = 0 To REG_COUNT - 1
        If lngRegCount(i) > 0 Then
            If lngRegCount(i) > 1 Then
                ptr.RegisterMultiples = True
            Else
                ' If the register is ESP the SIB byte needs to be written.
                ' InstructionOutArgs() only writes it if RegisterMultiples is true,
                ' do so.
                If IdxToReg(i) = RegESP Then ptr.RegisterMultiples = True
            End If
            
            ptr.RegisterCount = ptr.RegisterCount + 1
            If ptr.RegisterCount > 2 Then Exit For
            lngUsedRegs(ptr.RegisterCount - 1) = lngRegCount(i)
            
        ElseIf lngRegCount(i) < 0 Then
            SetError "Negative multiple of register", udtInstr.Line, udtInstr.Section
            Exit Function
            
        End If
    Next
    
    If blnHasSymbols Then
        ptr.HasDisplacement = True
        ptr.DispSize = Bits32
    Else
        If lngDisplacement <> 0 Then
            ptr.HasDisplacement = True
            ptr.DispSize = GetFirstSetBit(SizesForInt(lngDisplacement))
            If ptr.DispSize > Bits8 Then
                ' Bits16 not possible because of ModR/M
                ptr.DispSize = Bits32
            End If
        Else
            If lngRegCount(RegToIdx(RegEBP)) > 0 Then
                If ptr.RegisterCount = 1 Then
                    ' EBP can only be encoded with a displacement,
                    ' so simply add a zero'ed 8 Bit displacement
                    ptr.HasDisplacement = True
                    ptr.DispSize = Bits8
                End If
            Else
                ptr.HasDisplacement = False
                ptr.DispSize = BitsUnknown
            End If
        End If
    End If
    
    If ptr.RegisterCount = 1 Then
        If (lngUsedRegs(0) = 4) Or (lngUsedRegs(0) = 8) Then
            ' Reg*4/8 must be encoded with SIB,
            ' but in this case there is not base register (ptr.RegisterCount = 1).
            ' Because of this a 32 Bit displacement is needed
            ptr.HasDisplacement = True
            ptr.DispSize = Bits32
        End If
    End If
    
    If ptr.RegisterCount > 2 Then
        SetError "Not more than two registers per pointer allowed", udtInstr.Line, udtInstr.Section
    Else
        ptr.ptr.UsedRegisters = ptr.RegisterCount
        ptr.ptr.DispSize = ptr.DispSize
        ValidateExpr = True
    End If
End Function


Private Function ParseSegmentReg(udtInstr As ASMInstruction) As Boolean
    If udtInstr.Segment <> SegUnknown Then
        SetError "Only one segment override per instruction", udtInstr.Line, udtInstr.Section
    Else
        udtInstr.Segment = SegStrToSeg(Token.Content)
        Match TokenSegmentReg
        
        If Match(TokenOpColon) Then
            ParseSegmentReg = True
        Else
            SetError "Expected: Colon after segment", udtInstr.Line, udtInstr.Section
        End If
    End If
End Function


Private Sub AddInstruction(udtInstr As ASMInstruction)
    ReDim Preserve m_udtInstrs(m_lngInstrCount) As ASMInstruction
    m_udtInstrs(m_lngInstrCount) = udtInstr
    m_lngInstrCount = m_lngInstrCount + 1
End Sub


' index of an imported function consists of two indexes
' library index is in the upper 16 bits, function index in the lower 16 bits
' of the returned Long
Private Function GetExternIndex(Name As String) As Long
    Dim i   As Long
    Dim j   As Long
    
    For i = 0 To m_lngExternCount - 1
        For j = 0 To m_udtExtern(i).FunctionCount - 1
            If StrComp(m_udtExtern(i).Functions(j), Name, vbTextCompare) = 0 Then
                GetExternIndex = i * &H10000 Or j
                Exit Function
            End If
        Next
    Next
    
    GetExternIndex = -1
End Function


' IAT address of an imported function
' reladdr should be the start of the IAT relative to the Image Base
Private Function GetExternRelOfFnc(ByVal libidx As Long, ByVal fncidx As Long, ByVal reladdr As Long) As Long
    Dim i   As Long
    Dim j   As Long
    Dim sz  As Long
    
    For i = 0 To libidx - 1
        sz = sz + 4 * (m_udtExtern(i).FunctionCount + 1)
    Next
    sz = sz + 4 * fncidx
    
    GetExternRelOfFnc = sz + m_lngBaseAddress + reladdr
End Function


' start of imported functions of a specific library
' in the import lookup table relative to IAT
Private Function GetILTLibStart(ByVal Index As Long) As Long
    Dim im  As IMAGE_IMPORT_DIRECTORY
    Dim sz  As Long
    
    sz = GetNeededIATSize() + GetIATLibStart(Index)
    sz = sz + Len(im) * (m_lngExternCount + 1)
    
    GetILTLibStart = sz
End Function


' start of imported functions of a specific library in the IAT
' (which should fill the first bytes in the data section)
Private Function GetIATLibStart(ByVal Index As Long) As Long
    Dim i   As Long
    Dim sz  As Long
    
    For i = 0 To Index - 1
        sz = sz + 4 * (m_udtExtern(i).FunctionCount + 1)
    Next
    
    GetIATLibStart = sz
End Function


' size of IAT
Private Function GetNeededIATSize() As Long
    Dim i   As Long
    Dim sz  As Long
    
    For i = 0 To m_lngExternCount - 1
        sz = sz + 4 * (m_udtExtern(i).FunctionCount + 1)
    Next
    
    GetNeededIATSize = sz
End Function


' size of imports (IAT+ILT+names)
Private Function GetNeededImportsSize() As Long
    Dim i   As Long
    Dim j   As Long
    Dim sz  As Long
    Dim im  As IMAGE_IMPORT_DIRECTORY
    
    For i = 0 To m_lngExternCount - 1
        sz = sz + EvenSize(Len(m_udtExtern(i).LibName) + 1)
        sz = sz + Len(im)
        
        For j = 0 To m_udtExtern(i).FunctionCount - 1
            sz = sz + EvenSize(Len(m_udtExtern(i).Functions(j)) + 1) + 2
            sz = sz + 4 * 2
        Next
        
        sz = sz + 4 * 2
    Next
    
    If m_lngExternCount > 0 Then
        sz = sz + Len(im)
    End If
    
    GetNeededImportsSize = sz
End Function


Private Function RoundToSectionSize(ByVal lngVal As Long) As Long
    RoundToSectionSize = RoundTo(lngVal, MEM_SECTION_SIZE)
End Function


Private Function RoundToMinSize(ByVal lngVal As Long) As Long
    RoundToMinSize = RoundTo(lngVal, FILE_SECTION_SIZE)
End Function


Private Function RoundTo(ByVal lngVal As Long, ByVal lngMult As Long) As Long
    If lngVal Mod lngMult Then
        RoundTo = lngVal + (lngMult - lngVal Mod lngMult)
    Else
        RoundTo = lngVal
    End If
End Function


Private Function EvenSize(ByVal sz As Long) As Long
    EvenSize = sz + (sz Mod 2)
End Function


' hex string to byte array
Private Function HexToByte(ByVal strHex As String) As Byte()
    Dim bt()    As Byte
    Dim i       As Long
    
    ReDim bt(Len(strHex) \ 2 - 1) As Byte
    
    For i = 1 To Len(strHex) Step 2
        bt((i - 1) \ 2) = CByte("&H" & Mid$(strHex, i, 2))
    Next
    
    HexToByte = bt
End Function


Private Function GetLabelIndex(Name As String) As Long
    Dim i   As Long
    
    For i = 0 To m_lngLabelCount - 1
        If StrComp(m_udtLabels(i).Name, Name, vbTextCompare) = 0 Then
            GetLabelIndex = i
            Exit Function
        End If
    Next
    
    GetLabelIndex = -1
End Function


Private Sub SetError(ByVal strMsg As String, ByVal lngLine As Long, ByVal Section As String)
    m_strLastError = strMsg
    m_lngLastErrLine = lngLine
    m_strLastErrorSection = Section
End Sub


' match function for going through tokens after TokenizeInput()
' as there's need of doing a second pass
Private Function Match(ByVal tp As TokenType) As Boolean
    If m_clsTokens(m_lngCurToken).TType = tp Then
        m_lngCurToken = m_lngCurToken + 1
        Match = True
    End If
End Function


' Token property for accessing the current token after TokenizeInput()
' as there's need of doing a second pass
Private Property Get Token() As ASMToken
    Set Token = m_clsTokens(m_lngCurToken)
End Property


' collects all tokens and combines signs and numbers
Private Sub TokenizeInput()
    Dim blnInPtr    As Boolean
    Dim clsMinus    As ASMToken
    
    Do
        If clsMinus Is Nothing Then
            AddToken ScannerToken
        End If
        
        If ScannerToken.TType = TokenEndOfInput Then
            Exit Do
        Else
            ScannerGetNextToken
            Select Case ScannerToken.TType
            Case TokenBracketLeft:
                blnInPtr = True
            Case TokenBracketRight:
                blnInPtr = False
            Case TokenOpSub:
                If Not blnInPtr Then Set clsMinus = ScannerToken
            Case TokenValue:
                If Not clsMinus Is Nothing Then
                    ScannerToken.Value = -ScannerToken.Value
                    Set clsMinus = Nothing
                End If
            Case Else:
                If Not clsMinus Is Nothing Then
                    AddToken clsMinus
                    Set clsMinus = Nothing
                End If
            End Select
        End If
    Loop
End Sub


Private Sub AddLabel(strName As String, ByVal lngInstr As Long)
    ReDim Preserve m_udtLabels(m_lngLabelCount) As ASMLabel
    
    With m_udtLabels(m_lngLabelCount)
        .Name = strName
        .Instruction = lngInstr
        .Offset = 0
    End With
    
    m_lngLabelCount = m_lngLabelCount + 1
End Sub


Private Sub AddToken(ByVal clsTk As ASMToken)
    ReDim Preserve m_clsTokens(m_lngTokenCount) As ASMToken
    Set m_clsTokens(m_lngTokenCount) = clsTk
    m_lngTokenCount = m_lngTokenCount + 1
End Sub


'#########################################################
'#########################################################
' Scanner functions


Private Function ScannerMatch(udeType As TokenType) As Boolean
    If m_udtScanner.CurToken.TType = udeType Then
        ScannerGetNextToken
        ScannerMatch = True
    End If
End Function


Private Property Get ScannerToken() As ASMToken
    Set ScannerToken = m_udtScanner.CurToken
End Property


Private Sub ScannerInit(Source As String)
    With m_udtScanner
        .Source = StrConv(Source & vbCrLf, vbFromUnicode)
        .Length = UBound(.Source) + 1
        
        .Position = 0
        .Line = 1
        .LinePos = 0
        .NextIsEOI = False
        .LastWasEOI = True
        .Section = "main"
        
        Set .NextToken = New ASMToken
        With .NextToken
            .TType = TokenBeginOfInput
            .Line = 1
            .Position = 0
        End With
        
        ScannerGetNextToken
    End With
End Sub


Private Sub ScannerGetNextToken()
    Dim clsToken    As ASMToken
    
    Set clsToken = New ASMToken
    Set m_udtScanner.CurToken = m_udtScanner.NextToken
    
    If m_udtScanner.NextIsEOI Then
        clsToken.TType = TokenEndOfInstruction
        m_udtScanner.NextIsEOI = False
        m_udtScanner.LastWasEOI = True
    Else
        With m_udtScanner
            Do While (.Position < .Length) And (clsToken.TType = TokenUnknown)
                Select Case .Source(.Position)
                    
                Case CHAR_SPACE:
                    ' nichts tun
                    
                Case CHAR_CARRIAGE:
                    clsToken.TType = TokenEndOfInstruction
                    
                Case CHAR_VERT_BAR:
                    .Line = .Line + 1
                    .LinePos = .LinePos + 1
                    clsToken.TType = TokenEndOfInstruction
                    
                Case CHAR_LINEFEED:
                    .Line = .Line + 1
                    .LinePos = .LinePos + 1
                    
                Case CHAR_SHARP:
                    .Section = ""
                    .Line = 0
                    .LinePos = 0
                    .Position = .Position + 1
                    
                    Do
                        .Section = .Section & ChrW$(.Source(.Position))
                        .Position = .Position + 1
                    Loop While .Source(.Position) <> CHAR_CARRIAGE
                    
                    .Position = .Position - 1
                    
                Case CHAR_SEMICOLON:
                    Do
                        .Position = .Position + 1
                    Loop While .Source(.Position + 1) <> CHAR_CARRIAGE And _
                    .Source(.Position + 1) <> CHAR_VERT_BAR
                    
                Case CHAR_SEPARATOR:
                    clsToken.TType = TokenSeparator
                    clsToken.Content = ","
                    
                Case CHAR_COLON:
                    clsToken.TType = TokenOpColon
                    clsToken.Content = ":"
                    
                Case CHAR_PLUS:
                    clsToken.TType = TokenOpAdd
                    clsToken.Content = "+"
                    
                Case CHAR_MINUS:
                    clsToken.TType = TokenOpSub
                    clsToken.Content = "-"
                    
                Case CHAR_ASTERISK:
                    clsToken.TType = TokenOpMul
                    clsToken.Content = "*"
                    
                Case CHAR_BRACKET_L:
                    clsToken.TType = TokenBracketLeft
                    clsToken.Content = "["
                    
                Case CHAR_BRACKET_R:
                    clsToken.TType = TokenBracketRight
                    clsToken.Content = "]"
                    
                Case CHAR_NUMBER_0 To CHAR_NUMBER_9:
                    Do
                        clsToken.Content = clsToken.Content & ChrW$(.Source(.Position))
                        .Position = .Position + 1
                    Loop While IsDigit(.Source(.Position))
                    
                    clsToken.TType = TokenValue
                    .Position = .Position - 1
                    
                Case CHAR_AMPERSAND:
                    Select Case ChrW$(.Source(.Position + 1))
                        
                    Case "H", "O":
                        clsToken.Content = "&"
                        .Position = .Position + 1
                        
                        Do
                            clsToken.Content = clsToken.Content & ChrW$(.Source(.Position))
                            .Position = .Position + 1
                        Loop While IsHexChar(.Source(.Position))
                        
                        clsToken.TType = TokenValue
                        .Position = .Position - 1
                        
                    Case Else:
                        clsToken.TType = TokenInvalid
                        clsToken.Content = "&"
                        
                    End Select
                    
                Case CHAR_QUOTE:
                    .Position = .Position + 1
                    Do While .Source(.Position) <> CHAR_QUOTE And _
                        .Source(.Position) <> CHAR_CARRIAGE And _
                        .Source(.Position) <> CHAR_LINEFEED
                        
                        clsToken.Content = clsToken.Content & ChrW$(.Source(.Position))
                        .Position = .Position + 1
                    Loop
                    clsToken.TType = TokenString
                    
                Case CHAR_ALPHA_UA To CHAR_ALPHA_UZ, CHAR_ALPHA_LA To CHAR_ALPHA_LZ:
                    Do
                        clsToken.Content = clsToken.Content & ChrW$(.Source(.Position))
                        .Position = .Position + 1
                    Loop While IsAlphaNumeric(.Source(.Position))
                    
                    If IsRegister(clsToken.Content) Then
                        clsToken.TType = TokenRegister
                    ElseIf IsSegmentReg(clsToken.Content) Then
                        clsToken.TType = TokenSegmentReg
                    ElseIf IsFPUReg(clsToken.Content) Then
                        clsToken.TType = TokenFPUReg
                    ElseIf IsKeyword(clsToken.Content) Then
                        clsToken.TType = TokenKeyword
                    ElseIf IsRawDataOp(clsToken.Content) Then
                        clsToken.TType = TokenRawData
                    ElseIf IsMMReg(clsToken.Content) Then
                        clsToken.TType = TokenMMRegister
                    ElseIf StrComp(clsToken.Content, "extern", vbTextCompare) = 0 Then
                        clsToken.TType = TokenExtern
                    Else
                        clsToken.TType = TokenSymbol
                    End If
                    
                    .Position = .Position - 1
                    
                Case Else:
                    clsToken.TType = TokenInvalid
                    clsToken.Content = ChrW$(.Source(.Position))
                    
                End Select
                
                If .Source(.Position) = CHAR_CARRIAGE Then
                    .LastWasEOI = True
                Else
                    If clsToken.TType <> TokenKeyword And _
                        clsToken.TType <> TokenSymbol And _
                        .Source(.Position) <> CHAR_SPACE Then
                        .LastWasEOI = False
                    End If
                End If
                
                .Position = .Position + 1
            Loop
            
            If (clsToken.TType = TokenUnknown) And (.Position = .Length) Then
                clsToken.TType = TokenEndOfInput
            End If
        End With
    End If
    
    ' ** If the just scanned token is ":" then the previous token is a segment register
    '    or a label. In the last case the ":" must be followed by a line break.
    '    So add an invisible break (m_blnNextIsEOI).
    ' ** If the just scanned token is a string and the previous token is a line break
    '    or the begin of the input stream, then the current one probably is an operator.
    '    But it still can be followed by a colon and become a label in the next call to
    '    ScannerGetNextToken.
    ' ** ASMToken.Content kann contain hexadecimal or octal values.
    '    Supported is only VB style encoding (&H/&HO...)
    With clsToken
        If .TType = TokenOpColon Then
            If m_udtScanner.CurToken.TType = TokenOperator Then
                m_udtScanner.CurToken.TType = TokenSymbol
                m_udtScanner.NextIsEOI = True
                m_udtScanner.LastWasEOI = False
            End If
        ElseIf .TType = TokenSymbol Then
            If m_udtScanner.CurToken.TType = TokenEndOfInstruction Or _
                m_udtScanner.CurToken.TType = TokenBeginOfInput Or _
                m_udtScanner.LastWasEOI Then
                .TType = TokenOperator
                m_udtScanner.LastWasEOI = False
            End If
        ElseIf .TType = TokenValue Then
            On Error Resume Next
            .Value = CLng(.Content)
            If Err Then .TType = TokenInvalid
            On Error GoTo 0
        End If
        
        .Line = m_udtScanner.Line
        .Section = m_udtScanner.Section
        .Position = (m_udtScanner.Position - Len(.Content)) - m_udtScanner.LinePos + 1
    End With
    
    Set m_udtScanner.NextToken = clsToken
End Sub


Private Function IsDigit(ByVal bt As Byte) As Boolean
    IsDigit = (bt >= CHAR_NUMBER_0) And (bt <= CHAR_NUMBER_9)
End Function


Private Function IsHexChar(ByVal bt As Byte) As Boolean
    IsHexChar = ((bt >= CHAR_NUMBER_0) And (bt <= CHAR_NUMBER_9)) Or _
    ((bt >= CHAR_ALPHA_UA) And (bt <= CHAR_ALPHA_UA + 5)) Or _
    ((bt >= CHAR_ALPHA_LA) And (bt <= CHAR_ALPHA_LA + 5))
End Function


Private Function IsAlphaNumeric(ByVal bt As Byte) As Boolean
    IsAlphaNumeric = ((bt >= CHAR_NUMBER_0) And (bt <= CHAR_NUMBER_9)) Or _
    ((bt >= CHAR_ALPHA_UA) And (bt <= CHAR_ALPHA_UZ)) Or _
    ((bt >= CHAR_ALPHA_LA) And (bt <= CHAR_ALPHA_LZ)) Or _
    (bt = CHAR_UNDERSCORE)
End Function
